home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / bitmapedit.lsp < prev    next >
Text File  |  1990-10-11  |  2KB  |  55 lines
  1. ; book pp.257-260
  2.  
  3. (defproto bitmap-edit-proto '(bitmap h v) nil graph-window-proto)
  4.  
  5. (defmeth bitmap-edit-proto :isnew (width height)
  6.   (setf (slot-value 'bitmap)
  7.         (make-array (list height width) :initial-element 0))
  8.   (call-next-method))
  9. (defmeth bitmap-edit-proto :bitmap () (slot-value 'bitmap))
  10. (defmeth bitmap-edit-proto :v () (slot-value 'v))
  11. (defmeth bitmap-edit-proto :h () (slot-value 'h))
  12. (defmeth bitmap-edit-proto :resize ()
  13.   (let ((m (array-dimension (send self :bitmap) 0))
  14.         (n (array-dimension (send self :bitmap) 1))
  15.         (height (send self :canvas-height))
  16.         (width (send self :canvas-width)))
  17.      (setf (slot-value 'v)
  18.            (coerce (floor (* (iseq 0 m) (/ height m))) 'vector))
  19.      (setf (slot-value 'h)
  20.            (coerce (floor (* (iseq 0 n) (/ width n))) 'vector))))
  21. (defmeth bitmap-edit-proto :draw-pixel (i j)
  22.   (let* ((b (send self :bitmap))
  23.          (v (send self :v))
  24.          (h (send self :h))
  25.          (left (aref h j))
  26.          (right (aref h (+ j 1)))
  27.          (top (aref v i))
  28.          (bottom (aref v (+ i 1))))
  29.     (send self (if (= 1 (aref b i j)) :paint-rect :erase-rect)
  30.           left top (- right left) (- bottom top))))
  31. (defmeth bitmap-edit-proto :redraw ()
  32.   (let* ((b (send self :bitmap))
  33.          (m (array-dimension b 0))
  34.          (n (array-dimension b 1))
  35.          (width (send self :canvas-width))
  36.          (height (send self :canvas-height)))
  37.      (send self :start-buffering)
  38.      (send self :erase-rect 0 0 width height)
  39.      (dotimes (i m)
  40.               (dotimes (j n)
  41.                        (send self :draw-pixel i j)))
  42.      (send self :buffer-to-screen)))
  43. (defmeth bitmap-edit-proto :set-pixel (x y)
  44.   (let* ((b (send self :bitmap))
  45.          (m (array-dimension b 0))
  46.          (n (array-dimension b 1))
  47.          (width (send self :canvas-width))
  48.          (height (send self :canvas-height))
  49.          (i (min (floor (* y (/ m height))) (- m 1)))
  50.          (j (min (floor (* x (/ n width))) (- n 1))))
  51.      (setf (aref b i j) (if (= (aref b i j) 1) 0 1))
  52.      (send self :draw-pixel i j)))
  53. (defmeth bitmap-edit-proto :do-click (x y m1 m2)
  54.   (send self :set-pixel x y))
  55.